C---------------------------------------------------------
C    TOOLPACK/1    Release: 3.1
C---------------------------------------------------------
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.4
C---------------------------------------------------------
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.4
C---------------------------------------------------------
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.4
C---------------------------------------------------------
 
 
 
 
 
 
 
 
C                                   parameter length
 
 
 
 
 
 
 
 
 
C following are for ZYCSDT (Canonicalise Symbol Data Types)
C *****************************
C *  Note:  The following macro definition should be set to the
C *         maximum number of symbols expected in any single
C *         program-unit.  On a virtual-memory system, it can
C *         be set to the maximum number of symbols possible,
C *         i.e.    "define(max_pu_syms,max_symbols)"
C *
C *         For non-virtual systems, this may take up too much space,
C *         so make it smaller, e.g.
C *                 "define(max_pu_syms,500)"
C *****************************
C * The following setting is in use at NAG Central Office:
        PROGRAM ISTVS
 
        COMMON/VSIO/IODSYM,IODLST
        INTEGER IODSYM,IODLST
 
        COMMON/VSSYMI/SYMIDX,NSYMS
        INTEGER SYMIDX(1000),NSYMS
 
        INTEGER HEADER(81),SYMPTH(81),LSTPTH(81),I,
     +          YY,MMM,DD,HH,MM,SS,MILLI
 
        INTEGER GETARG,OPEN,CREATE
        EXTERNAL GETARG,OPEN,CREATE,ZYINSY,ZINIT,ZQUIT,ZMESS,PUTLIN,
     +           PUTCH,ZTIME,ZTIMST,ZCHOUT
 
        CALL ZINIT
 
        IF (GETARG(1,SYMPTH,81).EQ.-100) CALL NAMES(1,SYMPTH)
        IF (GETARG(2,LSTPTH,81).EQ.-100) CALL NAMES(2,LSTPTH)
        IF (GETARG(3,HEADER,81).EQ.-100) CALL NAMES(3,HEADER)
 
        IODSYM=OPEN(SYMPTH,0)
        IF (IODSYM.EQ.-1) CALL ERROR('Can''t open symbol path')
        IODLST=CREATE(LSTPTH,1)
        IF (IODLST.EQ.-1) CALL ERROR('Can''t create list path')
 
        CALL ZYINSY(IODSYM)
 
        CALL PUTLIN(HEADER,IODLST)
        CALL ZCHOUT(': Symbol Table Listing, ',IODLST)
        CALL ZTIME(YY,MMM,DD,HH,MM,SS,MILLI)
        CALL ZTIMST(YY,MMM,DD,HH,MM,SS,HEADER)
        CALL PUTLIN(HEADER,IODLST)
        CALL PUTCH(10,IODLST)
        CALL PUTCH(10,IODLST)
        I=1
 
 100    CALL ZYGSSI(SYMIDX,NSYMS,I)
        IF (NSYMS.EQ.0) THEN
            CALL ZMESS('[ISTVS Normal Termination]',1)
            CALL ZQUIT(-2)
        END IF
        CALL GETDAT
        CALL SRTIDX
        CALL PRINTS
        I=I+1
        GO TO 100
 
        END
C ----------------------------------------------------------------------
C
C       N A M E S   -   Input names of files and so on
C
 
        SUBROUTINE NAMES(NUMBER,STRING)
        INTEGER NUMBER,STRING(81)
 
        INTEGER PROMPT(22,3),JUNK
 
        SAVE PROMPT
 
        INTEGER ZGTCMD
        EXTERNAL ZPRMPT,ZGTCMD
 
C "Input symbol table: "
C "Output listing file: "
C "Header text: "
 
        DATA (PROMPT(I,1),I=1,21)/73,110,112,117,116,32,115,
     +121,109,98,111,108,32,116,97,98,108,101,58,
     +32,129/,
     +       (PROMPT(I,2),I=1,22)/79,117,116,112,117,116,32,
     +108,105,115,116,105,110,103,32,102,105,108,101,
     +58,32,129/,
     +       (PROMPT(I,3),I=1,14)/72,101,97,100,101,114,32,
     +116,101,120,116,58,32,129/
 
        CALL ZPRMPT(PROMPT(1,NUMBER))
        JUNK=ZGTCMD(STRING,0)
 
        END
C ----------------------------------------------------------------------
C
C       G E T D A T   -   Get symbol data
C
 
        SUBROUTINE GETDAT
 
        COMMON/VSSYMI/SYMIDX,NSYMS
        INTEGER SYMIDX(1000),NSYMS
 
        COMMON/VSSYMD/SYMBOL
        INTEGER SYMBOL(8,1000)
 
        INTEGER I
 
        DO 100 I=1,NSYMS
 100        CALL ZYGTSY(SYMIDX(I),SYMBOL(1,I))
 
        END
C ----------------------------------------------------------------------
C
C       S R T I D X   -   Sort symbol index
C
C       Sort key: Symbol type (then) Current position
C                 (Current position is as sorted by name)
C
 
        SUBROUTINE SRTIDX
 
        COMMON/VSSYMI/SYMIDX,NSYMS
        INTEGER SYMIDX(1000),NSYMS
 
        COMMON/VSSYMD/SYMBOL
        INTEGER SYMBOL(8,1000)
 
        INTEGER I,J,K,TMP(8),T
 
C We will use a form of straight insertion
        DO 300 I=2,NSYMS
            J=I-1
C while J>1 and a(i).lt.a(j) do j=j-1
 100        IF (SYMBOL(1,I) .LT. SYMBOL(1,J)) THEN
                J=J-1
                IF (J.GE.1) GOTO 100
            END IF
            J=J+1
            DO 150 T=1,8
 150            TMP(T)=SYMBOL(T,I)
            DO 250 K=I,J+1,-1
                DO 200 T=1,8
 200                SYMBOL(T,K)=SYMBOL(T,K-1)
 250        CONTINUE
            DO 275 T=1,8
 275            SYMBOL(T,J)=TMP(T)
 300    CONTINUE
        END
C ----------------------------------------------------------------------
C
C       P R I N T S   -   Print Symbols
C
 
        SUBROUTINE PRINTS
 
        COMMON/VSIO/IODSYM,IODLST
        INTEGER IODSYM,IODLST
 
        COMMON/VSSYMI/SYMIDX,NSYMS
        INTEGER SYMIDX(1000),NSYMS
 
        COMMON/VSSYMD/SYMBOL
        INTEGER SYMBOL(8,1000)
 
        INTEGER I,TEXT(134)
 
        EXTERNAL ZCHOUT,PUTCH,ZOBLNK,ZPTINT
 
        I=0
 100    I=I+1
        IF (SYMBOL(1,I).NE.4) GOTO 100
 
        CALL PUTCH(10,IODLST)
        CALL ZCHOUT('Program Unit: ',IODLST)
        CALL WRNAME(I)
        IF (SYMBOL(4,I).GT.0) CALL ZCHOUT(' FUNCTION',iodlst)
        CALL PUTCH(10,IODLST)
        CALL WRBITS(I)
 
        I=1
        IF (SYMBOL(1,I).EQ.1 .AND. I.LE.NSYMS) THEN
            CALL ZMESS('        Labels:',IODLST)
 200        CALL ZOBLNK(12,IODLST)
            CALL WRNAME(I)
            CALL ZCHOUT(', Node ',IODLST)
            CALL ZPTINT(SYMBOL(4,I),1,IODLST)
            CALL ZCHOUT(', Refs (ctl,do,io,ass) ',IODLST)
            CALL ZPTINT(SYMBOL(5,I),1,IODLST)
            CALL PUTCH(44,IODLST)
            CALL ZPTINT(MOD(SYMBOL(6,I),1000),
     +                  1,IODLST)
            CALL PUTCH(44,IODLST)
            CALL ZPTINT(SYMBOL(7,I),1,IODLST)
            CALL PUTCH(44,IODLST)
            CALL ZPTINT(SYMBOL(6,I)/1000,1,
     +                  IODLST)
            CALL PUTCH(10,IODLST)
            I=I+1
            IF (SYMBOL(1,I).EQ.1 .AND. I.LE.NSYMS)
     +          GOTO 200
        END IF
        IF (SYMBOL(1,I).EQ.2 .AND. I.LE.NSYMS) THEN
            CALL ZMESS('        Common blocks:',IODLST)
 300        CALL ZOBLNK(12,IODLST)
            CALL WRNAME(I)
            CALL ZCHOUT(', First definition node: ',IODLST)
            CALL ZPTINT(SYMBOL(4,I),1,IODLST)
            CALL PUTCH(10,IODLST)
            I=I+1
            IF (SYMBOL(1,I).EQ.2 .AND. I.LE.NSYMS)
     +          GOTO 300
        END IF
        IF (SYMBOL(1,I).EQ.3 .AND. I.LE.NSYMS) THEN
            CALL ZMESS('        Names (Usage Unknown):',IODLST)
 400        CALL ZOBLNK(12,IODLST)
            CALL WRNAME(I)
            CALL PUTCH(10,IODLST)
            CALL WRBITS(I)
            I=I+1
            IF (SYMBOL(1,I).EQ.3 .AND. I.LE.NSYMS)
     +          GOTO 400
        END IF
C SYMBOL(symbol_type,I) must = S_PU ... skip it
        I=I+1
        IF (SYMBOL(1,I).EQ.5 .AND. I.LE.NSYMS) THEN
            CALL ZMESS('        Variables:',IODLST)
 500        CALL ZOBLNK(12,IODLST)
            CALL WRNAME(I)
            IF (SYMBOL(7,I).NE.0) THEN
                CALL ZCHOUT('Array declarator node: ',IODLST)
                CALL ZPTINT(SYMBOL(7,I),1,IODLST)
            END IF
            CALL PUTCH(10,IODLST)
            CALL WRBITS(I)
            I=I+1
            IF (SYMBOL(1,I).EQ.5 .AND. I.LE.NSYMS)
     +          GOTO 500
        END IF
        IF (SYMBOL(1,I).EQ.6 .AND. I.LE.NSYMS) THEN
            CALL ZMESS('        Parameters:',IODLST)
 600        CALL ZOBLNK(12,IODLST)
            CALL WRNAME(I)
            CALL ZCHOUT(', Definition node ',IODLST)
            CALL ZPTINT(SYMBOL(7,I),1,IODLST)
            CALL PUTCH(10,IODLST)
            CALL WRBITS(I)
            I=I+1
            IF (SYMBOL(1,I).EQ.6 .AND. I.LE.NSYMS)
     +          GOTO 600
        END IF
        IF (SYMBOL(1,I).EQ.7 .AND. I.LE.NSYMS) THEN
            CALL ZMESS('        Procedures:',IODLST)
 700        CALL ZOBLNK(12,IODLST)
            CALL WRNAME(I)
            CALL PUTCH(10,IODLST)
            CALL WRBITS(I)
            I=I+1
            IF (SYMBOL(1,I).EQ.7 .AND. I.LE.NSYMS)
     +          GOTO 700
        END IF
        IF (SYMBOL(1,I).EQ.8 .AND. I.LE.NSYMS) THEN
            CALL ZMESS('        Statement Functions:',IODLST)
 800        CALL ZOBLNK(12,IODLST)
            CALL WRNAME(I)
            CALL ZCHOUT(', Definition node ',IODLST)
            CALL ZPTINT(SYMBOL(7,I),1,IODLST)
            CALL PUTCH(10,IODLST)
            CALL WRBITS(I)
            I=I+1
            IF (SYMBOL(2,I).EQ.8 .AND. I.LE.NSYMS) GOTO 800
        END IF
        IF (SYMBOL(1,I).EQ.9 .AND. I.LE.NSYMS) THEN
            CALL ZMESS('        Entry Points:',IODLST)
 900        CALL ZOBLNK(12,IODLST)
            CALL WRNAME(I)
            CALL PUTCH(10,IODLST)
            CALL WRBITS(I)
            I=I+1
            IF (SYMBOL(2,I).EQ.9 .AND. I.LE.NSYMS)
     +          GOTO 900
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       W R N A M E   -   Write symbol name and data type if any
C
 
        SUBROUTINE WRNAME(N)
        INTEGER N
 
        COMMON/VSIO/IODSYM,IODLST
        INTEGER IODSYM,IODLST
 
        COMMON/VSSYMI/SYMIDX,NSYMS
        INTEGER SYMIDX(1000),NSYMS
 
        COMMON/VSSYMD/SYMBOL
        INTEGER SYMBOL(8,1000)
 
        CHARACTER*17 TYPTXT(-3:15)
 
        SAVE TYPTXT
 
        INTEGER TEXT(134)
 
        EXTERNAL ZYGTST,PUTLIN,ZCHOUT,PUTCH,ZPTINT
 
        DATA TYPTXT/
     +'Main Program.    ',
     +'BLOCK DATA.      ',
     +'SUBROUTINE.      ',
     +'Unknown.         ',
     +'INTEGER.         ',
     +'REAL.            ',
     +'LOGICAL.         ',
     +'COMPLEX.         ',
     +'DOUBLE PRECISION.',
     +'CHARACTER.       ',
     +'DOUBLE COMPLEX.  ',
     +'Generic.         ',
     +'Hollerith.       ',
     +'Label.           ',
     +'Substring spec.  ',
     +'LOGICAL*1.       ',
     +'LOGICAL*2.       ',
     +'INTEGER*2.       ',
     +'REAL*16.         '/
 
        CALL ZYGTST(SYMBOL(2,N),TEXT)
        CALL PUTLIN(TEXT,IODLST)
        IF (SYMBOL(1,N).EQ.2 .OR.
     +      SYMBOL(1,N).EQ.1) RETURN
        CALL PUTCH(32,IODLST)
        CALL ZCHOUT(TYPTXT(SYMBOL(4,N)),IODLST)
        IF (SYMBOL(5,N).NE.0) THEN
            CALL PUTCH(42,IODLST)
            IF (SYMBOL(5,N).GT.0) THEN
                CALL ZPTINT(SYMBOL(5,N),1,IODLST)
            ELSE
                CALL ZCHOUT('(Node ',IODLST)
                CALL ZPTINT(-SYMBOL(5,N),1,IODLST)
                CALL PUTCH(41,IODLST)
            END IF
        END IF
        CALL PUTCH(32,IODLST)
 
        END
C ----------------------------------------------------------------------
C
C       W R B I T S   -   Write meaning of attribute bits
C
 
        SUBROUTINE WRBITS(N)
        INTEGER N
 
        INTEGER NBITS
        PARAMETER (NBITS=22)
 
        COMMON/VSIO/IODSYM,IODLST
        INTEGER IODSYM,IODLST
 
        COMMON/VSSYMD/SYMBOL
        INTEGER SYMBOL(8,1000)
 
        INTEGER BITS,I
        CHARACTER*50 BITTXT(NBITS)
 
        SAVE BITTXT,/VSIO/,/VSSYMD/
 
        INTEGER ZIAND
        EXTERNAL ZMESS,ZIAND
 
        DATA (BITTXT(I),I=1,19)/
     +'                Declared EXTERNAL.                ',
     +'                Declared INTRINSIC.               ',
     +'                Formal parameter.                 ',
     +'                Explicitly typed.                 ',
     +'                In ASSIGN statement.              ',
     +'                Assigned to on lhs of "=".        ',
     +'                In READ input list.               ',
     +'                In DATA statement.                ',
     +'                Statement function formal param.  ',
     +'                In EQUIVALENCE statement.         ',
     +'                In COMMON block.                  ',
     +'                Used as an actual argument.       ',
     +'                Standard intrinsic function.      ',
     +'                Called as a function.             ',
     +'                In an expression.                 ',
     +'                Called as a subroutine.           ',
     +'                Used as a DO-loop index.          ',
     +'                Actual argument to external.      ',
     +'                Parameter value known.            '/
        DATA (BITTXT(I),I=20,NBITS)/
     +'                Equivalenced into a common block. ',
     +'                *** unassigned flag bit ***.      ',
     +'                In INCLUDE file.                  '/
 
        BITS=SYMBOL(6,N)
 
        DO 100 I=1,NBITS
            IF (ZIAND(BITS,1).NE.0) CALL ZMESS(BITTXT(I),IODLST)
            BITS=BITS/2
 100    CONTINUE
 
        END
